home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / TYPE.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  61KB  |  1,867 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "segment.h"
  15. #include "gvars.h"
  16. #include "attr.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "axqrp.h"
  20. #include "setp.h"
  21. #include "dbxp.h"
  22. #include "initobjp.h"
  23. #include "maincasp.h"
  24. #include "gmainp.h"
  25. #include "arithp.h"
  26. #include "segmentp.h"
  27. #include "genp.h"
  28. #include "exprp.h"
  29. #include "gutilp.h"
  30. #include "arithp.h"
  31. #include "genp.h"
  32. #include "miscp.h"
  33. #include "gmiscp.h"
  34. #include "smiscp.h"
  35. #include "statp.h"
  36. #include "typep.h"
  37.  
  38. static void init_enum(Symbol, Segment, int, int);
  39. static void install_type(Symbol, Segment, int);
  40. static Segment make_fixed_template(Const, Const, Const, Const,
  41.   struct tt_fx_range **);
  42. static void split_powers(int *);
  43. static void process_record(Symbol);
  44. static int linearize_record(Tuple, Node);
  45. static int discr_dep_subtype(Node);
  46. static void get_discr(Node, int *, int *);
  47. static void eval_max_size(Symbol, Tuple);
  48.  
  49. #define TT_PTR(p) (int **) p
  50. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  51. extern Segment   VARIANT_TABLE, FIELD_TABLE;
  52.  
  53. extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
  54. extern *ADA_MIN_INTEGER_MP, *ADA_MAX_INTEGER_MP;
  55. extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
  56. extern int *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
  57.  
  58. static char  *PRECISION_NOT_SUPPORTED = 
  59.   "Precision not supported by implementation. (Appendix F)";
  60. /* split_ variables use to report result from split_powers()*/
  61. static int split_powers_2, split_powers_5, split_powers_value;
  62.  
  63. /* Chapter 3: types */
  64. /* type elaboration */
  65.  
  66. void gen_type(Symbol type_name)                                    /*;gen_type*/
  67. {
  68.     /* This is the main procedure for type elaboration.
  69.      *
  70.      *   type_name : in the case of a type declaration, this is the
  71.      *               name of the type.
  72.      */
  73.  
  74.     Node l_node, u_node, d_node, s_node, low_node, high_node, entry_node;
  75.     Node name_node, pragma_id, pragma_list, pragma_op, pragma_val, value_node;
  76.     Symbol parent_type, comp_type, typ, entry_name, entry_type, index;
  77.     Symbol indx_type, task_proc;
  78.     Tuple type_list, index_list, tup, sig, entry_list;
  79.     int  nb_dim, lng, priority, offset;
  80.     long nb_elements, nb_len;    /* long to avoid overflow problems */
  81.     int family_number, len, global_flag, ubd, lbd;
  82.     int        collection_size;
  83.     Tuple    repr_tup;
  84.     Const low_const, high_const, delta_const, small_const;
  85.     Segment stemplate, static_template, non_static_template;
  86.     Fortup ft1;
  87.     struct tt_array *tt_array_ptr;
  88.     struct tt_e_range  *tt_e_range_ptr;
  89.     struct tt_access   *tt_access_ptr;
  90.     struct tt_task *tt_task_ptr;
  91.     struct tt_fx_range *tt_fx_range_ptr;
  92.  
  93. #ifdef TRACE
  94.     if (debug_flag)
  95.         gen_trace_symbol("GEN_TYPE", type_name);
  96. #endif
  97.  
  98.     switch(NATURE(type_name)) {
  99.  
  100.     case(na_type):
  101.         /* Case of FIXED types for which we create a template.
  102.          *  Also case of derived types.
  103.          */
  104.         if (is_fixed_type(type_name)) {
  105.             sig = SIGNATURE(type_name);
  106.             l_node = (Node) sig[2];
  107.             u_node = (Node) sig[3];
  108.             d_node = (Node) sig[4];
  109.             s_node = (Node) sig[5];
  110.  
  111.             low_const = get_ivalue(l_node);
  112.             high_const = get_ivalue(u_node);
  113.             delta_const = get_ivalue(d_node);
  114.             small_const = get_ivalue(s_node);
  115.             stemplate = make_fixed_template(low_const, high_const, delta_const,
  116.               small_const, &tt_fx_range_ptr);
  117.             /* SETL ver supports 2 kinds of fixed point, in C we have only 1 */
  118.             tt_fx_range_ptr->fxlow = ADA_MIN_FIXED + 1;
  119.             tt_fx_range_ptr->fxhigh = ADA_MAX_FIXED;
  120.             TYPE_KIND(type_name) = TK_LONG;
  121.             TYPE_SIZE(type_name) = su_size(TK_LONG);
  122.  
  123.             install_type(type_name, stemplate, TRUE);
  124.             root_type(type_name) = type_name;
  125.         }
  126.         else {        /* Derived type */
  127.             parent_type = TYPE_OF(type_name);
  128.             assign_same_reference(type_name, parent_type);
  129.             TYPE_KIND(type_name) = TYPE_KIND(parent_type);
  130.             TYPE_SIZE(type_name) = TYPE_SIZE(parent_type);
  131.         }
  132.         break;
  133.  
  134.     case(na_array):
  135.         tup = (Tuple) SIGNATURE(type_name);
  136.         index_list = (Tuple) tup[1];
  137.         comp_type = (Symbol) tup[2];
  138.         if (is_entry_type(comp_type))
  139.             return;
  140.         nb_dim = tup_size(index_list);
  141.         nb_elements = 1L;
  142.         FORTUP(index = (Symbol), index_list, ft1);
  143.             len = length_of(index);
  144.             if (len >= 0)
  145.                 nb_elements *= len;
  146.             else
  147.                 nb_elements = -1L;
  148.         ENDFORTUP(ft1);
  149.         if ((nb_elements >= 0L) && has_static_size(comp_type)) {
  150.             /* want TYPE_SIZE to be number of storage units for array , */
  151.             /* TBSL: check that TYPE_KIND assignment below right,
  152.               * as in SETL just have TYPE_SIZE assignment of course 
  153.               */
  154.             TYPE_KIND(type_name) = TYPE_KIND(comp_type);
  155.             nb_len= nb_elements * TYPE_SIZE(comp_type);
  156.             if (nb_len > MAX_STATIC_SIZE) nb_len = -1;
  157.             TYPE_SIZE(type_name) = nb_len;
  158.         }
  159.         else {
  160.             TYPE_SIZE(type_name) = -1;
  161.         }
  162.         stemplate = template_new(TT_U_ARRAY, size_of(type_name),
  163.           WORDS_ARRAY - 4, TT_PTR(&tt_array_ptr));
  164.         /* TBSL: need to define field TT_U_ARRAY_DIMENSIONS: byte or integer? */
  165.         tt_array_ptr->dim = nb_dim;
  166.         global_flag = has_static_size(type_name);
  167.         type_list = tup_copy(index_list);
  168.         type_list = (Tuple) tup_with(type_list, (char *) comp_type);
  169.         while(tup_size(type_list)) {
  170.             typ = (Symbol) tup_frome(type_list);
  171.             reference_of(typ);
  172.             /* template      +:= ref; */
  173.             segment_put_int(stemplate, REFERENCE_SEGMENT);
  174.             segment_put_int(stemplate, (int) REFERENCE_OFFSET);
  175.             global_flag &= is_global(typ);
  176.         }
  177.         tup_free(type_list);
  178.         install_type(type_name, stemplate, global_flag);
  179.         break;
  180.  
  181.     case(na_record):
  182.         process_record(type_name);
  183.         break;
  184.  
  185.     case(na_enum):
  186.         /* this one is certainly static... */
  187.         sig = SIGNATURE(type_name);
  188.         low_node = (Node) sig[2];
  189.         high_node = (Node) sig[3];
  190.         lbd = get_ivalue_int(low_node);
  191.         ubd = get_ivalue_int(high_node);
  192.         stemplate = template_new(TT_ENUM, 1, WORDS_E_RANGE, 
  193.           TT_PTR(&tt_e_range_ptr));
  194.         tt_e_range_ptr->elow = lbd;
  195.         tt_e_range_ptr->ehigh = ubd;
  196.         init_enum(type_name, stemplate, lbd, ubd);
  197.         /* TYPE_SIZE(type_name) = ubd <= 255 ? mu_size(mu_byte) :
  198.           mu_size(mu_word); */
  199.         TYPE_KIND(type_name) = TK_WORD; /* only word case for 1st version */
  200.         TYPE_SIZE(type_name) = 1; /* only word case for 1st version ds*/
  201.         /* put that in the static segment.... */
  202.         install_type(type_name, stemplate, TRUE);
  203.         break;
  204.  
  205.     case(na_access):
  206.         /* Needs own template, as the accessed type contains a task
  207.          * (otherwise expander changed it to derived type from $ACCESS).
  208.          */
  209.         TYPE_KIND(type_name) = TYPE_KIND(symbol_daccess);
  210.         TYPE_SIZE(type_name) = TYPE_SIZE(symbol_daccess);
  211.         stemplate = template_new(TT_ACCESS, size_of(type_name),
  212.           WORDS_ACCESS, TT_PTR(&tt_access_ptr));
  213.         tt_access_ptr->master_task = 0;
  214.         tt_access_ptr->master_bfp = 0;
  215.         repr_tup = REPR(type_name);
  216.         if (repr_tup == (Tuple)0)         /* error condition */
  217.             value_node = OPT_NODE;
  218.         else 
  219.             value_node = (Node) repr_tup[3];
  220.         if (N_KIND(value_node) == as_opt) {
  221.            tt_access_ptr->collection_size = ADA_MAX_INTEGER;
  222.            tt_access_ptr->collection_avail = ADA_MAX_INTEGER;
  223.         }
  224.         else if (N_KIND(value_node) == as_ivalue) {
  225.            collection_size = INTV((Const)N_VAL(value_node));
  226.            tt_access_ptr->collection_size = collection_size;
  227.            tt_access_ptr->collection_avail = collection_size;
  228.         }
  229.         install_type(type_name, stemplate, FALSE);
  230.         if ((N_KIND(value_node) != as_opt) && 
  231.             (N_KIND(value_node) != as_ivalue)) {
  232.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  233.            gen_kic(I_ADD_IMMEDIATE, mu_word, 
  234.                    WORD_OFF(tt_access, collection_size), "collection size");
  235.            gen_value(value_node);
  236.            gen_kc(I_MOVE, mu_word, "update collection size");
  237.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  238.            gen_kic(I_ADD_IMMEDIATE, mu_word, 
  239.                    WORD_OFF(tt_access, collection_avail), "collection avail");
  240.            gen_value(value_node);
  241.            gen_kc(I_MOVE, mu_word, "update collection avail");
  242.         }
  243.         break;
  244.  
  245.     case(na_task_type_spec):
  246.     case(na_task_type):
  247.         entry_list